組員 : 張傳銘 傅昶曄 蔣佳伶 黃柏融 王澤恩
這邊用老師整理的資料集tf0,tf2。
rm(list=ls(all=TRUE))
Sys.setlocale("LC_TIME","C")## [1] "C"
pacman::p_load(magrittr, readr, caTools, ggplot2, dplyr,plotly,lubridate)
load("data/tf0.rdata")
load("data/tf2.rdata")將2001年2月的資料分割出來。
feb01 = as.Date("2001-02-01")
Z = subset(Z0, date < feb01) # 618212X = group_by(Z, tid) %>% summarise(
date = first(date), # 交易日期
cust = first(cust), # 顧客 ID
age = first(age), # 顧客 年齡級別
area = first(area), # 顧客 居住區別
items = n(), # 交易項目(總)數
pieces = sum(qty), # 產品(總)件數
total = sum(price), # 交易(總)金額
gross = sum(price - cost) # 毛利
) %>% data.frame # 88387summary(X)## tid date cust
## Min. : 1 Min. :2000-11-01 Length:88387
## 1st Qu.:22098 1st Qu.:2000-11-23 Class :character
## Median :44194 Median :2000-12-12 Mode :character
## Mean :44194 Mean :2000-12-15
## 3rd Qu.:66291 3rd Qu.:2001-01-12
## Max. :88387 Max. :2001-01-31
## age area items pieces
## Length:88387 Length:88387 Min. : 1.000 Min. : 1.000
## Class :character Class :character 1st Qu.: 2.000 1st Qu.: 3.000
## Mode :character Mode :character Median : 5.000 Median : 6.000
## Mean : 6.994 Mean : 9.453
## 3rd Qu.: 9.000 3rd Qu.: 12.000
## Max. :112.000 Max. :339.000
## total gross
## Min. : 5.0 Min. :-1645.0
## 1st Qu.: 230.0 1st Qu.: 23.0
## Median : 522.0 Median : 72.0
## Mean : 888.7 Mean : 138.3
## 3rd Qu.: 1120.0 3rd Qu.: 174.0
## Max. :30171.0 Max. : 8069.0
sapply(X[,6:9], quantile, prob=c(.999, .9995, .9999))## items pieces total gross
## 99.9% 56.0000 84.0000 9378.684 1883.228
## 99.95% 64.0000 98.0000 11261.751 2317.087
## 99.99% 85.6456 137.6456 17699.325 3389.646
X = subset(X, items<=64 & pieces<=98 & total<=11260) # 88387 -> 88295假設平均購買週期為30天(2K=30)
# K = as.integer(sum(A0$s[A0$f>1]) / sum(A0$f[A0$f>1])); K
K=15(一)我們是如何分群的? 我們先用三個參數(seniority,frequency,recency)把顧客分群,用ifelse條件式來將顧客區分潛力新星星(N1)、走過路過不錯過(N2)、我永遠忠誠(M1)、老子就是有錢(M2)、小資女孩向前衝(M3)、你怎麼還在睡(S)。 第一層 首先使用了「第一次消費距今天數」來判斷是否為新顧客,將我們的客群分成了「N」以及「M」兩個部分。
第二層(左) 使用了「頻率和客單價的乘積是否大於1400」來判斷是否為潛力顧客,把我們的顧客又分為「N1」和「N2」兩個部分。
第二層(右) 是使用了「購買頻率是否大於12天」把此層可群又分成「M1」和「M2、M3」兩個部分。 使用了「平均客單價是否大於1488」來做分群,分為「M2」以及「M3」兩群。
STS = c("N1","N2","S","M1","M2","M3")
Status = function(rx,fx,mx,sx,K) {factor(
ifelse(sx < 2*K,ifelse(fx*mx > 1400, "N1", "N2"),
ifelse(rx < 3*K,
ifelse(sx/fx < 0.8*K, "M1",
ifelse(mx > 1488, "M2", "M3")),"S") # mx*fx > 4752
), STS)} # ifelse(sx/fx < 0.75*K,"R2","R1")Fig-1: 規則分群圖
d0 = max(X$date) + 1
A = X %>% mutate(
days = as.integer(difftime(d0, date, units="days"))
) %>%
group_by(cust) %>% summarise(
recent = min(days), # 最後一次購買距期末天數
freq = n(), # 購買次數 (至期末為止)
money = mean(total), # 平均購買金額 (至期末為止)
senior = max(days), # 第一次購買距期末天數
rev = sum(total), # total revenue contribution
raw = sum(gross), # total gross profit contribution
age = age[1], # age group
area = area[1], # area code
status = Status(recent,freq,money,senior,K), # 期末狀態
date=date[1],
month=date[1] %>% month()
) %>% data.frame # 28584
nrow(A)## [1] 28584
table(A$status)##
## N1 N2 S M1 M2 M3
## 1617 2869 9969 2871 2352 8906
CustSegments = A %>%
group_by(status) %>% summarise(
average_frequency = mean(freq),
average_cycle= mean(senior/freq),
average_amount = mean(money),
average_recency = mean(recent),
average_seniority = mean(senior),
average_rev = mean(rev),
group_size = n()
)
a <- CustSegments%>% ggplot(aes(x=average_frequency, y=average_amount)) +
geom_point(aes(size=average_seniority, col=average_rev),alpha=0.5) +
scale_size(range=c(4,30)) +
scale_color_gradient(low="blue",high="red") +
scale_x_log10() + scale_y_log10(limits=c(30,3000)) +
geom_text(aes(label = status ),size=3) +
theme_bw() + guides(size=F) +
labs(title="Customer Segements",
subtitle="(bubble_size:revenue_seniority_contribution; text:group_size)",
color="Revenue") +
xlab("Average Frequency ") + ylab("Average Amount ")
ggplotly(a)CustSegments <- CustSegments %>% mutate(dummy=2000)# op = options(gvis.plot.tag='chart')
m1 = gvisMotionChart(
CustSegments, "status", "dummy",
options=list(width=1280, height=720))feb = filter(X0, date>= feb01) %>% group_by(cust) %>%
summarise(amount = sum(total)) A$amountSimply a Left Joint
A = merge(A, feb, by="cust", all.x=T)A$buyA$buy = !is.na(A$amount)summary(A)## cust recent freq money
## Length:28584 Min. : 1.00 Min. : 1.000 Min. : 8.0
## Class :character 1st Qu.:11.00 1st Qu.: 1.000 1st Qu.: 359.4
## Mode :character Median :21.00 Median : 2.000 Median : 709.5
## Mean :32.12 Mean : 3.089 Mean : 1012.4
## 3rd Qu.:53.00 3rd Qu.: 4.000 3rd Qu.: 1315.0
## Max. :92.00 Max. :60.000 Max. :10634.0
##
## senior rev raw age
## Min. : 1.00 Min. : 8 Min. : -742.0 Length:28584
## 1st Qu.:47.00 1st Qu.: 638 1st Qu.: 70.0 Class :character
## Median :68.00 Median : 1566 Median : 218.0 Mode :character
## Mean :61.27 Mean : 2711 Mean : 420.8
## 3rd Qu.:83.00 3rd Qu.: 3426 3rd Qu.: 535.0
## Max. :92.00 Max. :99597 Max. :15565.0
##
## area status date month
## Length:28584 N1:1617 Min. :2000-11-01 Min. : 1.000
## Class :character N2:2869 1st Qu.:2000-11-10 1st Qu.:11.000
## Mode :character S :9969 Median :2000-11-25 Median :11.000
## M1:2871 Mean :2000-12-01 Mean : 9.482
## M2:2352 3rd Qu.:2000-12-16 3rd Qu.:11.000
## M3:8906 Max. :2001-01-31 Max. :12.000
##
## amount buy
## Min. : 8 Mode :logical
## 1st Qu.: 454 FALSE:15342
## Median : 993 TRUE :13242
## Mean : 1499
## 3rd Qu.: 1955
## Max. :28089
## NA's :15342
tapply(A$buy, A$age, mean) %>% barplot
abline(h = mean(A$buy), col='red')tapply(A$buy, A$area, mean) %>% barplot(las=2)
abline(h = mean(A$buy), col='red')tapply(A$buy, A$status, mean) %>% barplot(las=2)
abline(h = mean(A$buy), col='red')X = subset(X, cust %in% A$cust & date < as.Date("2001-02-01"))
Z = subset(Z, cust %in% A$cust & date < as.Date("2001-02-01"))
set.seed(2018); spl = sample.split(A$buy, SplitRatio=0.7)
c(nrow(A), sum(spl), sum(!spl))## [1] 28584 20008 8576
TR = subset(A, spl)
TS = subset(A, !spl)glm1 = glm(buy ~ ., TR[,c(2:10, 14)], family=binomial())
summary(glm1)##
## Call:
## glm(formula = buy ~ ., family = binomial(), data = TR[, c(2:10,
## 14)])
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -3.7867 -0.8713 -0.6988 1.0378 1.8994
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.211e+00 1.451e-01 -8.346 < 2e-16 ***
## recent -1.411e-02 1.586e-03 -8.898 < 2e-16 ***
## freq 2.899e-01 1.990e-02 14.568 < 2e-16 ***
## money -3.522e-05 2.978e-05 -1.183 0.23692
## senior 8.880e-03 1.308e-03 6.787 1.15e-11 ***
## rev 4.164e-05 2.011e-05 2.071 0.03837 *
## raw -2.330e-04 8.564e-05 -2.720 0.00652 **
## agea25 -4.067e-02 8.666e-02 -0.469 0.63885
## agea30 1.945e-02 7.994e-02 0.243 0.80775
## agea35 7.855e-02 7.923e-02 0.991 0.32148
## agea40 8.824e-02 8.133e-02 1.085 0.27795
## agea45 2.113e-02 8.458e-02 0.250 0.80271
## agea50 2.080e-02 9.326e-02 0.223 0.82350
## agea55 1.778e-01 1.094e-01 1.625 0.10411
## agea60 6.359e-02 1.175e-01 0.541 0.58842
## agea65 2.677e-01 1.047e-01 2.556 0.01059 *
## agena -1.386e-01 1.499e-01 -0.925 0.35500
## areaz106 -3.771e-02 1.322e-01 -0.285 0.77536
## areaz110 -2.059e-01 1.045e-01 -1.971 0.04874 *
## areaz114 3.988e-02 1.111e-01 0.359 0.71958
## areaz115 2.635e-01 9.686e-02 2.720 0.00652 **
## areaz221 1.839e-01 9.757e-02 1.885 0.05942 .
## areazOthers -4.504e-02 1.045e-01 -0.431 0.66645
## areazUnknown -1.647e-01 1.233e-01 -1.336 0.18146
## statusN2 -5.588e-02 8.947e-02 -0.625 0.53227
## statusS 1.320e-01 1.167e-01 1.131 0.25790
## statusM1 2.071e-02 1.262e-01 0.164 0.86969
## statusM2 3.426e-02 1.050e-01 0.326 0.74427
## statusM3 2.633e-02 9.505e-02 0.277 0.78176
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 27629 on 20007 degrees of freedom
## Residual deviance: 23292 on 19979 degrees of freedom
## AIC: 23350
##
## Number of Fisher Scoring iterations: 5
pred = predict(glm1, TS, type="response")
cm = table(actual = TS$buy, predict = pred > 0.5); cm## predict
## actual FALSE TRUE
## FALSE 3722 881
## TRUE 1690 2283
acc.ts = cm %>% {sum(diag(.))/sum(.)}; acc.ts # 0.69998## [1] 0.7002099
colAUC(pred, TS$buy) # 0.7556## [,1]
## FALSE vs. TRUE 0.7556913
A2 = subset(A, A$buy) %>% mutate_at(c("money","rev","amount"), log10)
TR2 = subset(A2, spl2)
TS2 = subset(A2, !spl2)lm1 = lm(amount ~ ., TR2[,c(2:6,8:10,13)])
summary(lm1)##
## Call:
## lm(formula = amount ~ ., data = TR2[, c(2:6, 8:10, 13)])
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.85218 -0.22763 0.04808 0.27953 1.64720
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 1.0906870 0.0599624 18.190 < 2e-16 ***
## recent 0.0002348 0.0004967 0.473 0.63641
## freq 0.0238249 0.0018687 12.750 < 2e-16 ***
## money 0.5229903 0.0401586 13.023 < 2e-16 ***
## senior 0.0004441 0.0003970 1.119 0.26327
## rev 0.0254372 0.0385844 0.659 0.50974
## agea25 0.0725424 0.0251013 2.890 0.00386 **
## agea30 0.1198567 0.0230446 5.201 2.02e-07 ***
## agea35 0.1257094 0.0227280 5.531 3.27e-08 ***
## agea40 0.1375354 0.0232288 5.921 3.32e-09 ***
## agea45 0.1080843 0.0242443 4.458 8.36e-06 ***
## agea50 0.0774524 0.0264704 2.926 0.00344 **
## agea55 0.0711032 0.0312213 2.277 0.02279 *
## agea60 0.0686815 0.0320824 2.141 0.03232 *
## agea65 -0.0283561 0.0281998 -1.006 0.31466
## agena 0.1129738 0.0395279 2.858 0.00427 **
## areaz106 0.0754339 0.0434853 1.735 0.08283 .
## areaz110 0.0334820 0.0353367 0.948 0.34340
## areaz114 -0.0120253 0.0371340 -0.324 0.74607
## areaz115 0.0096498 0.0325586 0.296 0.76694
## areaz221 0.0138793 0.0327909 0.423 0.67211
## areazOthers 0.0235383 0.0349182 0.674 0.50027
## areazUnknown 0.0096210 0.0388698 0.248 0.80451
## statusN2 0.0924681 0.0292012 3.167 0.00155 **
## statusS 0.0267527 0.0369950 0.723 0.46961
## statusM1 0.0869293 0.0327794 2.652 0.00802 **
## statusM2 0.0705579 0.0315671 2.235 0.02543 *
## statusM3 0.0300611 0.0298220 1.008 0.31347
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.4211 on 9241 degrees of freedom
## Multiple R-squared: 0.2931, Adjusted R-squared: 0.291
## F-statistic: 141.9 on 27 and 9241 DF, p-value: < 2.2e-16
r2.tr = summary(lm1)$r.sq
SST = sum((TS2$amount - mean(TR2$amount))^ 2)
SSE = sum((predict(lm1, TS2) - TS2$amount)^2)
r2.ts = 1 - (SSE/SST)
c(r2.tr, r2.ts)## [1] 0.2930793 0.2605097
Aggregate data 2000-12-01 ~ 2001~02-28.
load("../unit15/data/tf0.rdata")
d0 = max(X0$date) + 1
B = X0 %>%
filter(date >= as.Date("2000-12-01")) %>%
mutate(days = as.integer(difftime(d0, date, units="days"))) %>%
group_by(cust) %>% summarise(
recent = min(days), # 最後一次購買距期末天數
freq = n(), # 購買次數 (至期末為止)
money = mean(total), # 平均購買金額 (至期末為止)
senior = max(days), # 第一次購買距期末天數
rev = sum(total), # total revenue contribution
raw = sum(gross), # total gross profit contribution
age = age[1], # age group
area = area[1], # area code
status = Status(recent,freq,money,senior,K),
date=date[1],
month=date[1] %>% month()
) %>% data.frame # 28531
nrow(B)## [1] 28531
In B, there is a record for each customer. B$Buy is the probability of buying in March.
B$Buy = predict(glm1, B, type="response")B2 = B %>% mutate_at(c("money","rev"), log10)
B$Rev = 10^predict(lm1, B2)par(mfrow=c(1,2), cex=0.8)
hist(B$Buy)
hist(log(B$Rev,10))g = 0.5 # (稅前)獲利率
N = 1 # 期數 = 5
d = 0.1 # 利率 = 10%
B$CLV = g * B$Rev * rowSums(sapply(
0:N, function(i) (B$Buy/(1+d))^i ) )
summary(B$CLV)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 40.34 383.53 592.20 700.80 872.50 31788.34
par(mar=c(2,2,3,1), cex=0.8)
hist(log(B$CLV,10), xlab="", ylab="")Segments <- sapply(B[,13:15], tapply, B$status, mean)
Segments## Buy Rev CLV
## N1 0.3187375 1170.7023 748.0283
## N2 0.2977436 620.8898 392.8461
## S 0.2927543 829.5184 523.2537
## M1 0.8633848 1517.0774 1376.9510
## M2 0.4520030 1752.5462 1240.7291
## M3 0.5333769 751.0267 562.8136
(一)潛力新星星(N1) 1. 特徵: (1) 此類型顧客的客單價偏高、且創造的總利潤位於第二位。 (2) 距離最近的消費日期是距今最短的,近期才做過第一次消費。 2. 態度: (1) 認為此類型顧客尚無所謂忠誠度。 (2) 可能屬於逛逛看、買買看的心態。 (3) 我們認為此類型顧客所擁有的消費潛力非常高,必須用心經營,使其成為我們的忠誠顧客。 3. 作法: (1) 分析此顧客群的主要購買產品,並定期研發其可能有興趣的新產品。 (2) 可利用假期、爆買期推出節日相關產品,維持其好奇心。 (3) 集點活動,這些顧客一開始的消費可能就可以讓他集到部分點數,而「差一點就集滿」的心態可能可以讓顧客願意再一次消費。
(二)走過路過不錯過(N2) 1. 特徵: (1) 此類型顧客的客單價、人數都屬於中偏低的位置。 (2) 距離最近的消費日期是距今最短的,近期才做過第一次消費。 2. 態度: (1) 認為此類型顧客尚無所謂忠誠度。 (2) 可能屬於逛逛看、買買看的心態。 (3) 年度促銷活動時可能大量出現。 3. 作法: (1) 可以在網路上投放廣告,使得這些新顧客時不時就會看見我們,並且在有需要的時候可以第一時間到我們的商店購物。 (2) 寄送定期E-mail讓此群顧客在看到促銷活動或是特惠時,可以來購買我們的產品。
(三)你怎麼還在睡(S) 1. 特徵: 此類型顧客的上一次消費日期距離現在非常久遠,且消費金額也不如其他類型高。 2. 態度: 我們會認為,此類型顧客對於我們的忠誠度不高、可能只是剛好路過,且對於我們所販售的產品需求也不大。因此,我們採取的態度是「能留最好,不留也罷」。 3. 作法: 每個檔期寄送E-mail。因為寄送E-mail不需要成本,且只要顧客有來過一次、留過資料,就可以使用此方法。
(四)我永遠忠誠(M1) 1. 特徵: (1) 為消費頻率最高的族群 (2) 雖然客單價並非最高,但因為頻率高,所達成的收益也有一定金額。 2. 態度: (1) 我們認為此客群的忠誠度是為最高的其中一個。 (2) 由於非常常到我們的店內做逛街,因此對於我們的商品可能非常了解。 3. 作法: (1) 可以定期打電話或是寄信詢問此群顧客對於我們的產品、服務有什麼樣的建議,可以使這群顧客感受到自己是被重視的,且會使其產生更強的歸屬感。 (2) 愈是忠誠的顧客在產品品質出問題時,喊的就愈大聲。因此我們必須要有強大的售後服務系統,在顧客一發出抱怨時,就要立刻處理、完成其需求。
(五)BELLAVITA / 老子就是有錢(M2) 1. 特徵: (1) 消費頻率屬於中偏低,並不是最高的。 (2) 平均客單價最高的族群,因此所創造的營收也很可觀。 2. 態度: 我們會認為,此類型顧客在選擇商品時,最重要的考慮點可能不是「價格」,而是商品的品質或是售後服務。 3. 作法: (1) 針對商品的品質做行銷點。(可以將我們的商品分為「省錢專區」以及「品質最保證」等區域,以符合不同消費者的需求) (2) VIP制度:消費滿一定金額,且每年都有消費者,可獲得專屬生日好禮、新品優先購買資格。 (3) 售後服務的部分: a. 在消費後一週內可以主動與消費者聯絡,關心其產品使用狀況,並詢問是否需要協助或需要改善之處。 b. 定期寄送簡訊或是E-mail、打電話給予生日祝福、年節祝福,使顧客感覺自己是被重視的、是特別的。 c. 拉攏新會員給優惠,物以類聚的概念,有錢人拉進來也是有錢人。
(六)小資女孩向前衝(M3) 1. 特徵: (1) 所造成的總營收並非最高、消費頻率也非最多。 (2) 人數龐大,僅次於沈睡顧客。 2. 態度: (1) 雖然營收並非最高,但消費頻率屬於中偏高,且人數非常多。因此我們不能放棄此客群,若每一個顧客的客單價都能夠增加一點點,對於營收的幫助非常龐大。 (2) 希望能夠讓這些顧客往「M1」前進,雖然單次消費價格無法達到像「M2」一樣多,但增加其購買頻率或是購買金額也能夠對營收有幫助。 3. 作法: (1) 集點活動 (2) 買大送小 (3) 加一元多一件
Segments## Buy Rev CLV
## N1 0.3187375 1170.7023 748.0283
## N2 0.2977436 620.8898 392.8461
## S 0.2927543 829.5184 523.2537
## M1 0.8633848 1517.0774 1376.9510
## M2 0.4520030 1752.5462 1240.7291
## M3 0.5333769 751.0267 562.8136
「小資女孩向前衝M3」 M3的消費習慣屬於不常來店消費、消費金額也不高的族群,從這兩點來看可以得知小資女孩們的顧客忠誠度還有很大的進步空間,如果透過行銷活動的操作,藉此激發小資女孩們的顧客潛能,使他們成為消費金額高又或者是來店頻率高的族群,來達到提升該族群的收入的效果。
「潛力新星星N1」 N1是屬於客單價較高的族群,但回購率不高,若能留住他們,提高其忠誠度,使其轉化為M1~3,為公司帶來“持續性”的收益。
我們所選擇的客群有以下兩個客群: (一)小資女孩向前衝(M3) 依據以上的分析,我們認為要讓這一群顧客發揮最大的價值,只要讓每一個人的平均消費金額上升,就可以達成我們的目標。因此可能可以有以下幾項作法: 1.集點活動 類似7-11、全聯的集點活動,以提高客單價。 (假如滿77元可以得到一點,那你現在消費75元,你就可能會多花錢來達到集點的價格。) 2.買大送小 可以把一些「利潤較高」的產品和一些原本賣的比較好的低利潤、低價格產品綁在一起賣,讓這些「利潤較高」的產品銷量提高。 (例如:在家電行內吹風機較好賣,但毛利較低,而大烤箱較難賣出,但毛利非常高。這時候就可以推出「買大烤箱送吹風機」活動,讓顧客感覺「賺到」,進而去使用我們的這個方案) 3.滿額贈 類似集點活動的概念,也是希望可以提高顧客的客單價。 (例如:百貨公司週年慶時會推出滿千送百活動,假設你購物滿950,就會想辦法去讓消費達到1000元。) 4.加價購 其實也是要提高該族群的客單價,像是屈臣氏,你本來只要購買某項特定產品,但在結帳時店員都會詢問你「需不需要加購後方商品」,會讓人覺得「啊!好像很划算」,所以就會多買東西回家。 5.邀請好友搶優惠 「邀請條碼」介紹新會員,這些小資族群對於價格彈性很高,給他們一點價格優惠就會激動得哇哇叫,因此透過介紹用戶進來就送折扣優惠可以達成族群壯大的目的。
(二)超級新星星(N1) 根據以上的分析,我們認為要讓這個客群發揮其最大價值,是要讓這群「消費客單價高」的顧客「下一次」能夠再來消費,保留下這些潛力顧客。 1.滿額辦會員卡 顧客每次消費滿200元即可獲得一點,顧客在集滿十點之後,即可獲得VIP會員卡一張。顧客在獲得VIP會員卡之後,只要憑卡來店消費即可享有9折的優惠,生日當天來店消費滿2000就送500現金抵用券。 2.新手專屬優惠 第一次消費過後可獲得專屬新手禮券、折價券,並限定在30天內用完,促使消費者在30天內會再來消費。 3.消費一週後電訪了解是否有建議、了解顧客感受
因為沒有成本資料,我們先假設營業獲利率為0.3
MRG = 0.3以M3為行銷對象
C = subset(B, status=="M3")
P0=C$Buy
R0=C$Rev cost = 5
k1 = 0.75 # fix effect on the probability of retaintionpar(mar=c(4,3,3,2), cex=0.8)
PI = R0*MRG*pmax(0, k1 - P0) - cost
hist(PI, xlim=c(-50, 50), breaks=seq(-500,500,5),main="淨期望報償分布(M3)")\[\Delta P_{ret} = \left\{\begin{matrix} k_2 & P_{retain}<=1-k_2 \\ 1-P_{retain} & else \end{matrix}\right.\]
k2 = 0.3 # max. incremental effect of instrument
cost = 5
par(mar=c(4,3,3,2), cex=0.8)
PI = MRG * R0 * ifelse(P0<=(1-k2), k2, 1-P0) - cost
hist(PI, xlim=c(0, 100), breaks=seq(-500,500,5),main="淨期望報償分布(M3)")B = B %>% mutate(
PI = MRG*Rev*ifelse(Buy<=(1-k2), k2, 1-Buy) - cost
)
B %>% group_by(status) %>%
summarise(
Group.Sz = n(),
No.Target = sum(PI>0),
AvgROI = mean(PI[PI>0]),
TotalROI = sum(PI[PI>0])) %>%
arrange(No.Target) %>%
data.frame## status Group.Sz No.Target AvgROI TotalROI
## 1 N1 1477 1477 100.28263 148117.4
## 2 M1 3189 2815 42.95883 120929.1
## 3 M2 2906 2906 149.44221 434279.1
## 4 N2 3732 3732 50.88008 189884.5
## 5 S 6790 6790 69.58728 472497.6
## 6 M3 10437 10437 58.84715 614187.7
par(mfrow=c(4,2), mar=c(4,3,3,2), cex=0.8)
for(s in c("N1","N2","S","M1","M2","M3")) {
hist(B$PI[B$status==s], xlim=c(-5, 100), breaks=seq(-1000,1000,10),
ylim=c(0, 1500), main=s, xlab="exp.profit")
abline(v=0, col='green', lty=2)}m=0.20; a=20; b=15
curve(m*plogis((10/a)*(x-b)), 0, 30, lwd=2, ylim=c(0, 0.25),
main=c('m*Logis(10(x - b)/a)'), ylab="f(x)")
abline(h=seq(0,0.2,0.05),v=seq(0,30,5),col='lightgrey',lty=2)m=0.20; a=20; b=15
do.call(rbind, lapply(seq(5,40,0.5), function(c){
p = m*plogis((10/a)*(c-b))
B %>% mutate(
PI = ifelse(Buy<=(1-p), p, 1-Buy) * Rev - c
) %>%
group_by(status) %>% summarise(
Cost = c,
Group.Sz = n(),
No.Target = sum(PI>0),
AvgROI = mean(PI[PI>0]),
TotalROI = sum(PI[PI>0])
) } ) ) %>%
ggplot(aes(x=Cost, y=TotalROI, col=status)) +
geom_line(size=1.2) +
ggtitle("Cost Effeciency per Segment ")由上方行銷模擬工具圖可以得知,總收益會隨著成本的投入而逐漸升高,至一定成本後邊際收益會遞減,當成本控制在20幾時,小資族會是帶來最高收益的族群,容易受到行銷活動的誘發,帶來更高效益,且可以發現這項工具用在M3會有最大的效益。
manipulate({
do.call(rbind, lapply(seq(5,40,0.5), function(c){
p = m*plogis((10/a)*(c-b))
B %>% mutate(
PI = ifelse(Buy<=(1-p), p, 1-Buy) * Rev - c
) %>%
group_by(status) %>% summarise(
Cost = c,
Group.Sz = n(),
No.Target = sum(PI>0),
AvgROI = mean(PI[PI>0]),
TotalROI = sum(PI[PI>0])
) } ) ) %>%
ggplot(aes(x=Cost, y=TotalROI, col=status)) +
geom_line(size=1.2) +
ggtitle("Cost Effeciency per Segment ")
},
m = slider(0.05, 0.25, 0.20, step=0.01),
a = slider( 10, 30, 20, step=1),
b = slider( 4, 20, 15, step=1)
)